perm filename T2.FOR[M11,LCS] blob sn#439871 filedate 1979-05-08 generic text, type T, neo UTF8
C THIS ROUTINE FINDS KEY WORDS IN I ARRAY AND PUTS THEIR KEY NUMS
C INTO THE IX ARRAY.  IX ARRAY ADVANCES 2 WORDS AT A TIME.
C IF 2ND WRD OF EACH PAIR IS NON-ZERO THEN 1ST IS FLT. PT. NUM.
C KCNT IS WORD COUNT OF INPUT STRING.
        SUBROUTINE MPACK(KCNT, I,IX,IPTR)
	INTEGER FQDR
	COMMON/IGEN/IGEN /FQDR/FQDR(28,27),INSN
CIN	COMMON /TR/Q(80),QX(100),IIX(100),LX(12),INST(27,4),K
	COMMON /TR/LX(12),K
	DIMENSION I(1),WDS(18)
	COMMON /WDZ/WDZ(14),JWD(12)
	DATA WDS/'OUT','OSC','AD2','RAN','ENV','STR','AD3','AD4',
	1 'MLT','DIV','RAH','END','REV','OPT','NOS','SUB','INP','COS'/,
	1 WDZ/'PLAY','FINI','SRAT','NCHN','PRIN','CHA','POWE','SRT',
	1 'WORD','GEN','SEG','SIN','INS','UNIT'/,
	1 JWD/'C','D','E','F','G','A','B','P','*','/',0,0/
	DATA IPP/'P'/,IFF/'F'/,IBB/'B'/,ISS/'S'/,
	1 IDD/'D'/,I2/'2'/,I3/'3'/,I4/'4'/,I0/'0'/,I9/'9'/,IPP/'P'/
	IX=I(1)
101	N=I(2)
	L=I(3)
	CALL PACKER(RNAM,I)
C NOW RNAM HAS PACKED WORD
	IF(IGEN.NE.2)GO TO 1000
C IGEN=2=READING INSTRUMENT DEFINITION
CODE NUMS ARE 1-13 FOR UNIT GENS., 100+ FOR B, 200+ FOR P, 300+ FOR F.
C ORD. OF UNIT GENS:OUT,OSC,AD2,RAN,ENV,STR,AD3,AD4,MLT,DIV,RAH,END,REV
C		OPT,NOS,SUB,INP,COS  
C OPT=OPTIONAL, NOS=OSC WHICH ACCEPTS NEG. FREQ., COS=CONTINUING NOS.
	IF(IX.EQ.IPP)GO TO 14
	IF(IX.EQ.IFF)GO TO 15
	IF(IX.EQ.IBB)GO TO 16
	IF(IX.EQ.IDD)GO TO 142
C  FPN = FREQ. PARAM. NUM.    DPN = DUR. PARAM. NUM.
	DO 102 IX=1,18
102	IF(RNAM.EQ.WDS(IX))RETURN
C SENDS BACK NUM FOR 1 TO 17
C IF NOT A KNOWN WORD THEN ERROR
999	IF(IGEN.EQ.2)GO TO 28
C  SO INST NAME CAN START WITH 'P' (BUT NO 'P12X', ETC.)
	CALL ERR(5)

141	JCVT=-1
	GO TO 143
142	JCVT=1
143	N=L
	L=I(4)
C SHIFT POINTER 1 TO RIGHT
	KCNT=KCNT-1
	GO TO 144
14	JCVT=0
144	J=200
C PN
18	IF(N.LT.I0.OR.N.GT.I9)GO TO 999
	K2=0
	K1=NASCI(N)
C  CONVERTS ASCII CHAR. TO INTEGER 
	IF(KCNT.EQ.2)GO TO 19
C ARE THERE 2 DIGITS AFTER P, F OR B?
	IF(L.LT.I0.OR.L.GT.I9)GO TO 999
	K1=K1*10
	K2=NASCI(L)
19	IX=J+K1+K2
	IF(JCVT.EQ.0)RETURN
C NOW SET UP A FREQ OR DUR FLAG 
	FQDR(K1+K2-2,INSN)=JCVT
	JCVT=0
	RETURN
15	IF(N.EQ.IPP)GO TO 141
C JUMP FOR 'FP'  = FREQ PARAM
	J=300
C  FN
	GO TO 18
16	J=100
C BN
	GO TO 18

C NEXT FOR OTHER (MUS10 TYPE) KEY WORDS.
1000	IF(KCNT.LT.3)GO TO 2000
C JUMP TO FIND NOTE NAMES, PARAMS, FUNCTS.
	DO 1 K=1,15
	IF(RNAM.NE.WDZ(K))GO TO 1
C THIS LIST BEGINS WITH CODE NUM. 400:
C PLAY,FINI,SRATE,NCHNS,PRINT,CHA,POWER,SRT,END,GEN,DUR,FREQ,INS,UNIT GEN
	IX=K+399
	RETURN
1	CONTINUE
	IF(IX.EQ.IPP)GO TO 14
C CHECK FOR A PARAM NUM OR INST. NAME
28	IX=-IPTR
C SEND BACK NEG. POINTER TO I ARRAY SO IT WILL LOOK FOR INST. NAME.
	RETURN

2000	DO 2 K=1,12
C FINDS (P1, P21, ETC.)
2	IF(IX.EQ.JWD(K))GO TO(5,11,7,4,6,8,9,14,15,16)K
	GO TO 28
C A FUNC??
4	IF(N.GE.I0.AND.N.LE.I9)GO TO 15
	IF(KCNT.EQ.3)GO TO 28
	IX=510
	GO TO 36
5	IX=501
C 'C'
C AT THIS POINT NOTE NUMBERS RUN FROM 500 TO 520  (CF TO BS)
	GO TO 36
6	IX=513
C THE NOTE 'G'
36	IF(KCNT.EQ.1)RETURN
	IF(N.EQ.IFF)GO TO 39
	IF(N.NE.ISS) GO TO 28
C NOW IT'S NOT A NOTE
40	IX=IX+1
C SHARP
	RETURN
39	IX=IX-1
C FLAT
	RETURN
11	IX=504
C  'D'
	GO TO 36
7	IF(KCNT.EQ.3)GO TO 4
C 'END' OR NOTE 'E'?
	IX=507
	GO TO 36
8	IX=516
	GO TO 36
9	IX=519
	GO TO 36
	END

      SUBROUTINE ERR(N)
	COMMON /DEVS/ID1,ID21,JTYPE,ID23,ID20
      GO TO (1,2,3,4,5)N
1      WRITE(JTYPE,101)
      STOP
101      FORMAT(' MISSING SEMICOLON')
2      WRITE(JTYPE,102)
      STOP
102      FORMAT(' MISSING PARENTHESIS')
3      WRITE(JTYPE,103)
      STOP
103      FORMAT(' MISSING COMMA')
4      WRITE(JTYPE,104)
104      FORMAT(' MISSING PLAY;')
5	WRITE(JTYPE,105)
105	FORMAT(' UNKNOWN WORD')
      STOP
      END

      SUBROUTINE ARITH(Y,W,LL)
      DIMENSION W(1)
      COMMON /AR/IOP
7      X=W(LL-1)
      GO TO (1,2,3,4,5),IOP
1      IF(Y.EQ.0)Y=16.
C  0 WILL ALWAYS TURN INTO 16 WITH MULT OR DIV.
	X=X*Y
      GO TO 6
2      IF(Y.EQ.0)Y=16.
       X=X/Y
      GO TO 6
3      X=X-Y
      GO TO 6
4      X=X+Y
	GO TO 6
5	X=X**Y
6      W(LL-1)=X
      END